SPACE 2/SPACE - Library 2 - Volume 1.iso/telecom/46/pascal/pr.pas

Pascal/Delphi Source File | 1986-08-15 | 6.9 KB | 231 lines

PROGRAM Pr ;
    { Program to make a printout of a listing or file    }
    { puts header with file name & date at top of page   }
    { puts a footer with page number at bottom pf page   }
    { uses item selector box to get the file to print    }
    { WILLIAM R. GOOD JULY 1986                          }

  CONST
    {$I GEMCONST.PAS}

  TYPE
    {$I gemtype.pas}
    prtype = FILE OF TEXT ;
    tftype = FILE OF TEXT ;

  VAR
    pathname, filename : Path_Name ;
    selection : boolean ;
    textfile : tftype ;
    prtfile : prtype ;
    result : integer ;

  {$I gemsubs}          { and that ".PAS" is default }

{ the next two functions are added to personal pascal }

FUNCTION t_getdate : integer ;
   GEMDOS( $2a ) ;

FUNCTION t_gettime : integer ;
   GEMDOS( $2c ) ;

PROCEDURE info ;
   { prints the copyright notice on the screen }
   { in a alert box. OSS wants this            }
   VAR
       button : integer ;
       alerttext : string[255] ;
       part1, part2, part3, part4, part5 : string ;
   BEGIN
       part1 := '[3][Pr by William R. Good|' ;
       part2 := 'Portions of this product are|' ;
       part3 := 'Copyright (c) 1986 OSS and CCD|' ;
       part4 := 'Used by Permission of OSS.|' ;
       part5 := 'Written on 07-26-86 ][ OK ]' ;
       alerttext := Concat ( part1, part2, part3, part4, part5 ) ;
       button := Do_Alert(alerttext,1) ;
   END ; { info }

PROCEDURE another ( var selection : integer ) ;
   { procedure to get a yes or no answer }
   VAR
      alerttext : string[255] ;
   BEGIN
      alerttext := '[2][Do another file][ YES | NO ]' ;
      selection := Do_Alert(alerttext,2) ;  { default no }
   END ; { another }

PROCEDURE Inttostr (int : integer; VAR inttext : string) ;
{Generic procedure to convert integers to strings, packs front with zeros.}
VAR
   place,digit : integer;
   tempstr : string ;
BEGIN
   tempstr := '' ;
   FOR place:=1 DOWNTO 0 DO
      BEGIN
         digit:=int DIV Round(PwrOfTen(place));
         tempstr := concat (tempstr, chr(digit+ord('0'))) ;
         int:=int MOD Round(PwrOfTen(place));
      END;
   inttext := tempstr ;
END; {Inttostr}

PROCEDURE getdate (var datestr : string ) ;
{ procedure to return the date in a string }
   VAR
      dateint,tempint,
      yearint, monthint, dayint : integer ;
      yearstr, monthstr, daystr : string ;
   BEGIN
      dateint := t_getdate ;
      yearint := dateint div 512 ;
      yearint := yearint + 80 ;
      tempint := dateint mod 512 ;
      monthint := tempint div 32 ;
      dayint := tempint mod 32 ;
      inttostr( yearint, yearstr ) ;
      inttostr( monthint, monthstr ) ;
      inttostr( dayint, daystr ) ;
      datestr := concat( monthstr, '/', daystr, '/', yearstr ) ;
   END ; { getdate }

PROCEDURE gettime (var timestr : string ) ;
{ procedure to return the time in a string }
   VAR
      timeint, tempint, tmpint,
      hourint, minint, secint : integer ;
      hourstr, minstr, secstr : string ;
   BEGIN
      timeint := t_gettime ;
      tmpint := 0 ;
      if timeint < 0 then
         begin
            timeint := $8000 + timeint ;
            tmpint := 16 ;
         end ;
      hourint := timeint div $800 ;
      tempint := timeint mod $800 ;
      minint := tempint div $20 ;
      secint := tempint mod $20 ;
      secint := secint * 2 ;
      hourint := hourint + tmpint ;
      inttostr( hourint, hourstr ) ;
      inttostr( minint, minstr ) ;
      inttostr( secint, secstr ) ;
      timestr := concat( hourstr, ':', minstr, ':', secstr ) ;
   END ; { gettime }

PROCEDURE printhead ;
        { prints header with full pathname  }
        { and date                          }
   var
      times1, times2, len, tmplen : integer ;
      headline, time, date, tabstr : string ;
   begin
      tabstr := ' ' ;
      rewrite( prtfile, 'LST:' ) ;
      for times1 := 1 to 2 do
         begin
            writeln( prtfile ) ;  { space down some lines }
         end ;
      getdate ( date ) ;
      gettime ( time ) ;
      len := length( filename ) ;
      tmplen := 60 - len ;
      repeat
         tmplen := tmplen - 1 ;
         tabstr := concat( tabstr, ' ' ) ;
      until tmplen < 1 ;
      headline := concat(filename, tabstr, time,' ', date ) ;
      writeln( prtfile, headline ) ; { need to add filename here }
      for times2 := 1 to 2 do
         begin
            writeln( prtfile ) ;
         end ;
   end ; { printhead }

PROCEDURE printfoot( pagenum : integer ) ;
        { prints footer with page number  }
        { at the bottom of page in center }
   var
      line, textline : string ;
      pagestr : string ;
      tempnum, index, times1, times2 : integer ;
   begin
      rewrite( prtfile, 'LST:' ) ;
      for times1 := 1 to 2 do
         begin
            writeln( prtfile ) ;
         end ;
      inttostr( pagenum, pagestr ) ;
      textline := '                             PAGE NUMBER : ' ;
      textline := concat( textline, pagestr ) ;
      writeln( prtfile, textline ) ;
      for times2 := 1 to 2 do
         begin
            writeln( prtfile ) ;
         end
   end ; { printfoot}

PROCEDURE printfile ;
   { prints the pascal file to the printer       }
   { prints header and footer with page number   }
   VAR
      textfile : tftype ;
      prtfile : prtype ;
      number, tempnum, strline : string ;
      check, linecount, pagenumber : integer ;
   BEGIN
      pagenumber := 0 ;
      linecount := 1 ;
      rewrite( prtfile, 'LST:' ) ;
      pathname := 'A:\*.*' ;
      selection := true ;
      selection := Get_In_File( pathname, filename ) ;
      if selection then
         begin
         set_mouse(m_bee) ;
         printhead ;
         reset( textfile, filename ) ;
         while (not eof( textfile )) do
            begin
               readln ( textfile, strline ) ;
               writeln ( prtfile, strline ) ;
               linecount := linecount + 1 ;
               if linecount = 57 then
                  begin
                     pagenumber := pagenumber + 1 ;
                     printfoot ( pagenumber ) ;
                     printhead ;
                     linecount := 1 ;
                  end ;
            end ;
            if linecount < 57 then
               begin
                  repeat
                     writeln ( prtfile ) ;
                     linecount := linecount + 1 ;
                  until linecount = 57 ;
                  pagenumber := pagenumber + 1 ;
                  printfoot ( pagenumber ) ;
               end ;
         set_mouse(m_arrow) ;
         end ;
   end ; { end printfile }

  BEGIN  {Main Module}
    IF Init_Gem >= 0 THEN
      BEGIN
         info ;
         repeat
            printfile ;
            close( textfile ) ;
            close( prtfile ) ;
            another( result ) ;
         until result <> 1 ;
         Exit_Gem ;
      END ;
  END. { Pr }